home *** CD-ROM | disk | FTP | other *** search
/ Australian Personal Computer 2002 November / CD 1 / APC0211D1.ISO / workshop / prog / files / ActivePerl-5.6.1.633-MSWin32.msi / _db43f72f6bd8bd33e03ba48bf53c76aa < prev    next >
Encoding:
Text File  |  2002-05-30  |  5.7 KB  |  167 lines
  1. # menus2.pl
  2.  
  3. use subs qw/menus_error2/;
  4. use vars qw/$TOP/;
  5.  
  6. sub menus2 {
  7.  
  8.     # This demonstration script creates a window with a bunch of menus
  9.     # and cascaded menus, but uses -menuitems rather than the Tcl/Tk way.
  10.  
  11.     my ($demo) = @_;
  12.     $TOP = $MW->WidgetDemo(
  13.         -name     => $demo,
  14.         -text     => '',                      
  15.         -title    => 'Menuitems Demonstration',
  16.         -iconname => 'menus2',
  17.     );
  18.  
  19.     my $menubar = $TOP->Frame(-relief => 'raised', -borderwidth => 2);
  20.     $menubar->grid(qw/-sticky ew/);
  21.     my $f = $menubar->Menubutton(qw/-text File -underline 0 -menuitems/ =>
  22.         [
  23.          [Button => 'Open ...',    -command => [\&menus_error2, 'Open']],
  24.      [Button => 'New',         -command => [\&menus_error2, 'New']],
  25.      [Button => 'Save',        -command => [\&menus_error2, 'Save']],
  26.      [Button => 'Save As ...', -command => [\&menus_error2, 'Save As']],
  27.      [Separator => ''],
  28.      [Button => 'Setup ...',   -command => [\&menus_error2, 'Setup']],
  29.      [Button => 'Print ...',   -command => [\&menus_error2, 'Print']],
  30.      [Separator => ''],
  31.      [Button => 'Quit',        -command => [$TOP => 'bell']],
  32.     ])->grid(qw/-row 0 -column 0 -sticky w/);
  33.  
  34.     my $b = $menubar->Menubutton(qw/-text Basic -underline 0 -menuitems/ =>
  35.         [
  36.      [Button => 'Long entry that does nothing'],
  37.       map (
  38.            [Button       => "Print letter \"~$_\"",
  39.             -command     => [sub {print "$_[0]\n"}, $_],
  40.             -accelerator => "Meta+$_" ],
  41.            ('a' .. 'g')
  42.       ), 
  43.     ])->grid(qw/-row 0 -column 1 -sticky w/);
  44.  
  45.     my $menu_cb = '~Check buttons';
  46.     my $menu_rb = '~Radio buttons';
  47.     my $c = $menubar->Menubutton(qw/-text Cascades -underline 0 -menuitems/ =>
  48.         [        
  49.      [Button => 'Print ~hello',   -command => sub {print "Hello\n"},
  50.       -accelerator => 'Control+a'],
  51.      [Button => 'Print ~goodbye', -command => sub {print "Goodbye\n"},
  52.       -accelerator => 'Control+b'],
  53.      [Cascade => $menu_cb, -menuitems =>
  54.       [
  55.        [Checkbutton => 'Oil checked',          -variable => \$OIL],
  56.        [Checkbutton => 'Transmission checked', -variable => \$TRANS],
  57.        [Checkbutton => 'Brakes checked',       -variable => \$BRAKES],
  58.        [Checkbutton => 'Lights checked',       -variable => \$LIGHTS],
  59.        [Separator => ''],
  60.        [Button => 'See current values', -command => 
  61.         [\&see_vars, $TOP, [
  62.                 ['oil',     \$OIL],
  63.                 ['trans',   \$TRANS],
  64.                 ['brakes',  \$BRAKES],
  65.                 ['lights',  \$LIGHTS],
  66.                 ],
  67.             ], # end see_vars
  68.        ], # end button
  69.       ], # end checkbutton menuitems
  70.      ], # end checkbuttons cascade
  71.      [Cascade => $menu_rb, -menuitems =>
  72.       [
  73.        map (
  74.         [Radiobutton => "$_ point", -variable => \$POINT_SIZE,
  75.          -value => $_,
  76.          ],
  77.         (qw/10 14 18 24 32/),
  78.         ),
  79.        [Separator => ''],
  80.        map (
  81.         [Radiobutton => "$_", -variable => \$FONT_STYLE,
  82.          -value => $_,
  83.          ],
  84.         (qw/Roman Bold Italic/),
  85.         ),
  86.        [Separator => ''],
  87.        [Button => 'See current values', -command =>
  88.         [\&see_vars, $TOP, [
  89.                 ['point size', \$POINT_SIZE],
  90.                 ['font style', \$FONT_STYLE],
  91.                 ],
  92.          ], # end see_vars
  93.         ], # end button
  94.        ], # end radiobutton menuitems
  95.       ], # end radiobuttons cascade
  96.          ])->grid(qw/-row 0 -column 2 -sticky w/);
  97.  
  98.     $TOP->bind('<Control-a>' => sub {print "Hello\n"});
  99.     $TOP->bind('<Control-b>' => sub {print "Goodbye\n"});
  100.  
  101.     # Fetch the Cascades menu, and from that get the checkbutton and
  102.     # radiobutton cascade menus and invoke a few menu items.
  103.  
  104.     my $cm = $c->cget(-menu);
  105.     $menu_cb = substr $menu_cb, 1;
  106.     my $cc = $cm->entrycget($menu_cb, -menu);
  107.     $cc->invoke(1);
  108.     $cc->invoke(3);
  109.     $menu_rb = substr $menu_rb, 1;
  110.     my $cr = $cm->entrycget($menu_rb, -menu);
  111.     $cr->invoke(1);
  112.     $cr->invoke(7);
  113.  
  114.     my $i = $menubar->Menubutton(qw/-text Icons -underline 0 -menuitems/ =>
  115.         [
  116.      [Button   => '', -bitmap => '@'.Tk->findINC('demos/images/pattern'),
  117.       -command => [$DIALOG_ICON => 'Show']],
  118.      map (
  119.           [Button  => '', -bitmap => $_,
  120.           -command => 
  121.            [sub {print "You invoked the \"$_[0]\" bitmap\n"}, $_]],
  122.           (qw/info questhead error/),
  123.           ),
  124.      ])->grid(qw/-row 0 -column 3 -sticky w/);
  125.  
  126.     my $m = $menubar->Menubutton(qw/-text More -underline 0 -menuitems/ =>
  127.         [
  128.      map (
  129.           [Button   => $_,
  130.            -command => 
  131.            [sub {print "You invoked \"$_[0]\"\n"}, $_]],
  132.           ('An entry', 'Another entry', 'Does nothing',
  133.            'Does almost nothing', 'Make life meaningful'),
  134.           ),
  135.      ])->grid(qw/-row 0 -column 4 -sticky w/);
  136.  
  137.     my $k = $menubar->Menubutton(qw/-text Colors -underline 1 -menuitems/ =>
  138.         [
  139.      map (
  140.           [Button      => $_,
  141.            -background => $_,
  142.            -command    => 
  143.            [sub {print "You invoked \"$_[0]\"\n"}, $_]],
  144.           (qw/red orange yellow green blue/),
  145.           ),
  146.      ])->grid(qw/-row 0 -column 5 -sticky w/);
  147.  
  148.     my $details = $TOP->Label(qw/-wraplength 4i -justify left -text/ => 'This window contains a collection of menus and cascaded menus.  You can post a menu from the keyboard by typing Alt+x, where "x" is the character underlined on the menu.  You can then traverse among the menus using the arrow keys.  When a menu is posted, you can invoke the current entry by typing space, or you can invoke any entry by typing its underlined character.  If a menu entry has an accelerator, you can invoke the entry without posting the menu just by typing the accelerator.', -font => $FONT)->grid;
  149.  
  150. } # end menus
  151.  
  152. sub menus_error2 {
  153.  
  154.  
  155.     # Generate a background error, which may even be displayed in a window if
  156.     # using ErrorDialog. 
  157.  
  158.     my($msg) = @_;
  159.  
  160.     $msg = "This is just a demo: no action has been defined for \"$msg\".";
  161.     $TOP->BackTrace($msg);
  162.  
  163. } # end menus_error
  164.  
  165.  
  166. 1;
  167.